home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Scrabble / board.icl < prev    next >
Encoding:
Modula Implementation  |  1997-05-14  |  14.7 KB  |  368 lines  |  [TEXT/3PRM]
  1. implementation module board
  2.  
  3. import    StdEnv
  4. import    language, types
  5.  
  6. /***************************************************************************************************************
  7.     The dimensions of the board have range of 0..14 to 0..14.
  8. ****************************************************************************************************************/
  9.  
  10. ::    Board    :==    (![[Char]],![[Char]])
  11.  
  12. initboard :: Board
  13. initboard
  14. =    (emptyboard,emptyboard)
  15. where
  16.     emptyboard = repeatn 15 (repeatn 15 ' ')
  17.  
  18. getplacedletters :: !Board -> [Char]
  19. getplacedletters (h,_)
  20. =    sort (removeDup (flatten h))
  21.  
  22.  
  23. /***************************************************************************************************************
  24.     The bonus fields on the scrabble board.
  25. ****************************************************************************************************************/
  26.  
  27. doubleletterpositions :: [Position]
  28. doubleletterpositions
  29.     =: [(0,3),(0,11),(2,6),(2,8),(3,7),(3,14),(6,2),(6,6),(6,8),(6,12),(7,3),(7,11),(8,2),(8,6),(8,8),(8,12),(11,7),(11,14),(12,6),(12,8),(14,3),(14,11)]
  30.  
  31. tripleletterpositions :: [Position]
  32. tripleletterpositions
  33.     =: [ (1,5),(1,9),(5,1),(5,5),(5,9),(5,13),(9,1),(9,5),(9,9),(9,13),(13,5),(13,9) ]
  34.  
  35. doublewordpositions :: [Position]
  36. doublewordpositions
  37.     =: [ (7,7),(1,1),(2,2),(3,3),(4,4),(1,13),(2,12),(3,11),(4,10),(10,4),(10,10),(11,3),(11,11),(12,12),(12,2),(13,13),(13,1) ]
  38.  
  39. triplewordpositions :: [Position]
  40. triplewordpositions
  41.     =: [ (0,0),(0,7),(0,14),(7,0),(7,14),(14,0),(14,7),(14,14) ]
  42.  
  43. lettervalueat :: !Char !Position -> Int
  44. lettervalueat l pos
  45. |    isMember pos doubleletterpositions    = lw*2
  46. |    isMember pos tripleletterpositions    = lw*3
  47. |    otherwise                            = lw
  48. where
  49.     lw = lettervalue l
  50.  
  51. wordvalueat :: !Position -> Int
  52. wordvalueat pos
  53. |    isMember pos doublewordpositions    = 2
  54. |    isMember pos triplewordpositions    = 3
  55. |    otherwise                            = 1
  56.  
  57. grab :: ![Char] !Int [Int] -> (![Char],![Char],[Int])
  58. grab lb 0 rs            = (lb,[],rs)
  59. grab [] n rs            = ([],[],rs)
  60. grab lb n rs            = (restbox,[l:rest],rs2)
  61. where
  62.     (r,rs1)                = random (length lb) rs
  63.     l                    = lb!!r
  64.     (restbox,rest,rs2)    = grab (removeFirst l lb) (n-1) rs1
  65.     
  66.     random :: !Int ![Int] -> (!Int,![Int])
  67.     random i [r:rs] = (r rem i,rs)
  68.     
  69.     removeFirst :: !x ![x] -> [x]    | Eq x
  70.     removeFirst x [y:ys]
  71.     |    x==y        = ys
  72.     |    otherwise    = [y:removeFirst x ys]
  73.     removeFirst _ _    = []
  74.  
  75. getfreehorpositions :: !Board !Char -> [Position]
  76. getfreehorpositions (h,_) l
  77. =    flatten (map (freepositions True l 0) (zip2 [0..] h))
  78.  
  79. getfreeverpositions :: !Board !Char -> [Position]
  80. getfreeverpositions (_,v) l
  81. =    map swap (flatten (map (freepositions True l 0) (zip2 [0..] v)))
  82.  
  83. freepositions :: !Bool !Char !Int !(!Int,![Char]) -> [Position]
  84. freepositions _ _ _ (_,[])
  85. =    []
  86. freepositions True k x (y,[l:ls])
  87. |    l==k        = [(x,y) : freepositions False k (x+1) (y,ls)]
  88. |    l==' '        = freepositions True  k (x+1) (y,ls)
  89. |    otherwise    = freepositions False k (x+1) (y,ls)
  90. freepositions False k x (y,[l:ls])
  91. |    l==' '        = freepositions True  k (x+1) (y,ls)
  92. |    otherwise    = freepositions False k (x+1) (y,ls)
  93.  
  94.  
  95. /***************************************************************************************************************
  96.     seekfreepositions is used by seekfree(hor/ver)positions. It determines the positions on a given board that 
  97.     are valid starting positions for a word starting with a particular letter.
  98.     
  99.     The function is useful when atleast one letter on the board has to be used because a (some) letter(s) is 
  100.     (are) missing on the letter bar.
  101. ****************************************************************************************************************/
  102. seekfreehorpositions :: !Board !Char !Int -> [Position]
  103. seekfreehorpositions (h,v) k p
  104. =    flatten (map (seekfreepositions 0 p k 0) (zip2 [0..] h))
  105.  
  106. swap :: !(.a,.b) -> (.b,.a)
  107. swap (a,b) = (b,a)
  108.  
  109. seekfreeverpositions :: !Board !Char !Int -> [Position]
  110. seekfreeverpositions (h,v) k p
  111. =    map swap (flatten (map (seekfreepositions 0 p k 0) (zip2 [0..] v) ))
  112.  
  113. seekfreepositions :: !Int !Int !Char !Int !(!Int,![Char]) -> [Position]
  114. seekfreepositions a p k x (y,[l:ls])
  115. |    a>=p && k==l        = [(x-p,y) : seekfreepositions 0 p k (x+1) (y,ls)]
  116. |    l==' '                = seekfreepositions (a+1) p k (x+1) (y,ls)
  117. |    otherwise            = seekfreepositions 0 p k (x+1) (y,ls)
  118. seekfreepositions _ _ _ _ _
  119. =    []
  120.  
  121.  
  122. /***************************************************************************************************************
  123.     tryaddword board word position direction adds word at position in direction to board. 
  124.     The Board    result is the new board.
  125.     The Boolean    result reports whether the word could be placed.
  126.     The [Char]    result are the letters that have been used.
  127.     The Int        result is the score by placing this word.
  128.     The [Word]    result are the possibly new formed words.
  129.     
  130.     After tryaddword it should be verified if the new formed words are legal. 
  131.     After tryaddword it also should be verified if a bonus should be added to the score in case all letters 
  132.     have been used.
  133. ****************************************************************************************************************/
  134. tryaddword :: !Board !Word !Position !Direction -> (!Board,!Bool,[Char],Int,[Word])
  135. tryaddword board=:(h,v) w (x,y) Hor
  136. |    w==""                = (board,True, [],0,[])
  137. |    size w + x > 15        = (board,False,[],0,[])
  138. |    otherwise            = ((nh,nv),possible,newletters,score,newwords)
  139. where
  140.     (nh,possible,scorenewletters,worddoubling)
  141.                         = tryaddtolines h w (x,y) y
  142.     (nv,vscore,newwords)= tryaddtransversetolines v (0,y) scorenewletters
  143.     newletters            = map fst3 scorenewletters
  144.     scoreoldletters        = oldletterscore w newletters
  145.     hscore                = worddoubling*(sum (map thd3 scorenewletters) + scoreoldletters)
  146.     score
  147.     |    not possible    = 0
  148.     |    otherwise        = hscore+vscore
  149. tryaddword board=:(h,v) w (x,y) Ver
  150. |    w==""                = (board,True, [],0,[])
  151. |    size w + y > 15        = (board,False,[],0,[])
  152. |    otherwise            = ((nh,nv),possible,newletters,vscore+hscore,newwords)
  153. where
  154.     (nv,possible,scorenewletters,worddoubling)
  155.                         = tryaddtolines v w (y,x) x
  156.     (nh,hscore,newwords)= tryaddtransversetolines h (0,x) scorenewletters
  157.     newletters            = map fst3 scorenewletters
  158.     scoreoldletters        = oldletterscore w newletters
  159.     vscore                = worddoubling*(sum (map thd3 scorenewletters) + scoreoldletters)
  160.  
  161. oldletterscore :: !Word ![Char] -> Int        // Sum the lettervalue of the chars in word that are not member of letters
  162. oldletterscore word letters
  163. =    sum (map lettervalue (removeMembers [c\\c<-:word] letters))
  164.  
  165. tryaddtolines :: ![[Char]] Word !Position !Int -> (![[Char]],!Bool,![(Char,Int,Int)],Int)
  166. tryaddtolines [r:rs] w p=:(x,_) 0
  167. #    (r,possible,scorenewletters,worddoubling) = tryaddtoline r w p x
  168. =    ([r:rs],possible,scorenewletters,worddoubling)
  169. where
  170.     tryaddtoline :: ![Char] !Word !Position !Int -> (![Char],!Bool,![(Char,Int,Int)],Int)
  171.     tryaddtoline rs word p 0
  172.     |    nrchars==1    = addtoline
  173.                     with
  174.                         addtoline
  175.                         |    l==' ' && (ls==[] || hd ls==' ')    = ([w:ls],True, [lwrd],wwrd)
  176.                         |    l==w   && (ls==[] || hd ls==' ')    = ([w:ls],True, [],1)
  177.                         |    otherwise                            = ([l:ls],False,[],1)
  178.     |    nrchars>=1    = addtoline
  179.                     with
  180.                         (nr,possible,lwrds,wwrds)                = tryaddtoline ls (word%(1,nrchars-1)) (x+1,y) 0
  181.                         addtoline
  182.                         |    l==' '                                = ([w:nr],possible,[lwrd:lwrds],wwrd*wwrds)
  183.                         |    l==w                                = ([w:nr],possible,lwrds,wwrds)
  184.                         |    otherwise                            = ([l:ls],False,[],1)
  185.     where
  186.         nrchars        = size word
  187.         (l,ls)        = hdtl rs
  188.         w            = word.[0]
  189.         (x,y)        = p
  190.         wvalue        = lettervalueat w p
  191.         lwrd        = (w,x,wvalue)
  192.         wwrd        = wordvalueat p
  193.     tryaddtoline rs word p 1
  194.     |    l<>' '                        = (rs,False,[],1)
  195.     #    (ls,possible,lwrds,wwrds)    = tryaddtoline ls word p 0
  196.     |    otherwise                    = ([l:ls],possible,lwrds,wwrds)
  197.     where
  198.         (l,ls)                        = hdtl rs
  199.     tryaddtoline [l:ls] word p n
  200.     #    (ls,possible,lwrds,wwrds)    = tryaddtoline ls word p (n-1)
  201.     =    ([l:ls],possible,lwrds,wwrds)
  202.     
  203.     hdtl :: ![.x] -> (.x,[.x])
  204.     hdtl [x:xs] = (x,xs)
  205. tryaddtolines [r:rs] w p j
  206. #    (rs,possible,scorenewletters,worddoubling) = tryaddtolines rs w p (j-1)
  207. =    ([r:rs],possible,scorenewletters,worddoubling)
  208. tryaddtolines _ _ _ _
  209. =    ([],False,[],0)
  210.  
  211. tryaddtransversetolines :: ![[Char]] !Position ![(Char,Int,Int)] -> (![[Char]],Int,![Word])
  212. tryaddtransversetolines rs _ []
  213. =    (rs,0,[])
  214. tryaddtransversetolines [r:rs] p=:(x,y) [(nl,nx,ls)]
  215. |    x==nx        = ([nr:rs],score,newword)
  216.                 with
  217.                     (nr,score,newword)    = addtoline r nl p y ""
  218. |    otherwise    = ([r:nrs],score,newword)
  219.                 with
  220.                     (nrs,score,newword)    = tryaddtransversetolines rs (x+1,y) [(nl,nx,ls)]
  221. tryaddtransversetolines [r:rs] p=:(x,y) [(nl,nx,ls):lwrds]
  222. |    x==nx        = ([nr:nrs],score+restscore,newword++newwords)
  223.                 with
  224.                     (nrs,restscore,newwords)= tryaddtransversetolines rs (x+1,y) lwrds
  225.                     (nr,score,newword)        = addtoline r nl p y ""
  226. |    otherwise    = ([r:nrs],restscore,newwords)
  227.                 with
  228.                     (nrs,restscore,newwords)= tryaddtransversetolines rs (x+1,y) [(nl,nx,ls):lwrds]
  229. tryaddtransversetolines [r:rs] (x,y) lwrds
  230. =    ([r:nrs],score,newwords)
  231. where
  232.     (nrs,score,newwords) = tryaddtransversetolines rs (x-1,y) lwrds
  233.  
  234. addtoline :: ![Char] !Char Position !Int !Word -> (![Char],Int,![Word])
  235. addtoline [l:ls] w p 0 initword
  236. |    initwordscore+restwordscore<>0    = ([w:ls],(initwordscore+lscore+restwordscore)*wscore,[word])
  237. |    otherwise                        = ([w:ls],0,[])
  238. where
  239.     lscore                = lettervalueat w p
  240.     wscore                = wordvalueat p
  241.     restword            = takeWhile ((<>) ' ') ls
  242.     initwordscore        = sum [lettervalue c \\ c<-:initword]
  243.     restwordscore        = sum (map lettervalue restword)
  244.     word                = initword +++ toString w +++ toString restword
  245. addtoline [l:ls] w p ry initword
  246. #    initword            = if (l<>' ') (initword+++toString l) ""
  247.     (ls,score,word)        = addtoline ls w p (ry-1) initword
  248. =    ([l:ls],score,word)
  249.  
  250.  
  251. /***************************************************************************************************************
  252.     newmaximumplacings _ lexicon letterbar _ (Letter l _) _ _ determines all valid words from lexicon that 
  253.     start with l and are member of letterbar.
  254. ****************************************************************************************************************/
  255. newmaximumplacings :: !Board Tree [Char] !(!Int,!Int,!Int,!Int) !Progress !Strength Bool -> Placing
  256. newmaximumplacings board wordlist computerletters (minx,maxx,miny,maxy) progress=:(Letter l placing) strength firstturn
  257. =    scoremax strength [placing:newfoundplacings1++newfoundplacings2]
  258. where
  259.     startwith                = wordsstartingwith l wordlist
  260.     uniquecomputerletters    = removeDup computerletters
  261.     poshor                    = getfreehorpositions board l
  262.     posver                    = getfreeverpositions board l
  263.     newfoundplacings1
  264.         = [ {word=nw,pos=p,dir=r,/*endscore*/score=if (length gl==7) (s+50) s}
  265.                                 \\    nw    <- startwith
  266.                                 ,    (firstmissingletter,position) <- [difference nw uniquecomputerletters 0]
  267.                                 ,    r <- [Hor,Ver]
  268.                                 ,    p <- if (position<>7) (if (r==Hor)
  269.                                                             (seekfreehorpositions board firstmissingletter position)
  270.                                                             (seekfreeverpositions board firstmissingletter position)
  271.                                                           )
  272.                                                           (if (r==Hor)
  273.                                                             [(i,j) \\ i <- [max 0 (minx-size nw) .. min (14-size nw) maxx]
  274.                                                                     , j <- [max 0 (miny-1)       .. min 14 (maxy+1)]]
  275.                                                             [(i,j) \\ i <- [max 0 (minx-1)       .. min 14 (maxx+1)]
  276.                                                                     , j <- [max 0 (miny-size nw) .. min (14-size nw) maxy]]
  277.                                                           )
  278.                                 ,    (_,m,gl,s,nws) <- [tryaddword board nw p r]
  279.                                 |    ok_solution m gl nws nw
  280.           ]
  281.     ok_solution m gl nws nw
  282.         = m                                                            && 
  283.           (not (isEmpty gl))                                        &&
  284.           isEmpty (removeMembers gl computerletters)                &&
  285.           ((not (isEmpty nws)) || length gl<>size nw || firstturn)    &&
  286.           allexist wordlist nws
  287.     newfoundplacings2
  288.         = addatpositions board wordlist computerletters (poshor,posver) progress firstturn
  289.     
  290. //    difference word letterbar determines which letter and its position in word that is not a member of letterbar. 
  291.     difference :: !Word ![Char] !Int -> (!Char,!Int)
  292.     difference word letters p
  293.     |    word==""            = ('a',7)
  294.     #    l                    = word.[0]
  295.         word                = word%(1,size word-1)
  296.     |    isMember l letters    = difference word letters (p+1)
  297.     |    otherwise            = (l,p)
  298.  
  299.  
  300. /***************************************************************************************************************
  301.     newmaximumplacing board lexicon letterbar (hor,ver) (Letter l _) _ _ determines all valid words from lexicon 
  302.     that start with l and are not member of letterbar. The positions hor++ver are assumed to be valid free 
  303.     positions on board starting with l.
  304. ****************************************************************************************************************/
  305. newmaximumplacing :: !Board Tree [Char] ([Position],[Position]) !Progress !Strength Bool -> Placing
  306. newmaximumplacing board wordlist computerletters poshv progress=:(Letter l placing) strength firstturn
  307. =    scoremax strength [placing:addatpositions board wordlist computerletters poshv progress firstturn]
  308. newmaximumplacing _ _ _ _ (Finish ready) _ _
  309. =    ready
  310.  
  311. addatpositions :: !Board Tree [Char] !([Position],[Position]) !Progress Bool -> [Placing]
  312. addatpositions board wordlist computerletters (poshor,posver) (Letter l _) firstturn
  313. =    [ {word=nw,pos=p,dir=r,/*endscore*/score=if (length gl==7) (s+50) s}
  314.                             \\    nw<- startwith
  315.                             |    wordcontainsletters nw uniquecomputerletters
  316.                             ,    r <- [Hor,Ver]
  317.                             ,    p <- if (r==Hor) poshor posver
  318.                             ,    (_,m,gl,s,nws) <- [tryaddword board nw p r]
  319.                             |    ok_solution m gl nws nw
  320.     ]
  321. where
  322.     ok_solution m gl nws nw
  323.         = m                                                            &&
  324.           not (isEmpty gl)                                            &&
  325.           isEmpty (removeMembers gl computerletters)                &&
  326.           (not (isEmpty nws) || length gl<>size nw || firstturn)    &&
  327.           allexist wordlist nws
  328.     startwith                = wordsstartingwith l wordlist
  329.     uniquecomputerletters    = removeDup computerletters
  330.     
  331.     wordcontainsletters :: !Word [Char] -> Bool
  332.     wordcontainsletters word letters
  333.     |    word==""                    = False
  334.     |    isMember word.[0] letters    = True
  335.     |    otherwise                    = wordcontainsletters (word%(1,size word-1)) letters
  336.  
  337.  
  338. /***************************************************************************************************************
  339.     scoremax selects a Placing depending on the Strength of the player.
  340. ****************************************************************************************************************/
  341. scoremax :: !Strength ![Placing] -> Placing
  342. scoremax First ps
  343. #    ps                    = dropWhile ((==) initplacing) ps
  344. |    isEmpty ps            = initplacing
  345. |    otherwise            = hd ps
  346. scoremax Maximum ps
  347. =    getmaxscore ps
  348. where
  349.     getmaxscore :: ![Placing] -> Placing
  350.     getmaxscore [p]            = p
  351.     getmaxscore [p1:ps]
  352.     |    p1.score>p2.score    = p1
  353.     |    otherwise            = p2
  354.     where
  355.         p2                    = getmaxscore ps
  356.     getmaxscore []            = initplacing
  357. scoremax (Strength percent) ps
  358. =    scoremax Maximum (take nr ps)
  359. where
  360.     nr    = toInt (toReal (length ps)*percent) + 1
  361.  
  362.  
  363. /***************************************************************************************************************
  364.     allexists is true only if each of the words in the [Word] argument can be found in the Tree argument.
  365. ****************************************************************************************************************/
  366. allexist :: Tree ![Word] -> Bool
  367. allexist wordlist words = and (map (seek wordlist) words)
  368.